home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / forth / pfe-0.000 / pfe-0 / pfe-0.9.13 / src / forth-83.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-07-17  |  6.7 KB  |  304 lines
  1. /*
  2.  * This file is part of the portable Forth environment written in ANSI C.
  3.  * Copyright (C) 1995  Dirk Uwe Zoller
  4.  *
  5.  * This library is free software; you can redistribute it and/or
  6.  * modify it under the terms of the GNU Library General Public
  7.  * License as published by the Free Software Foundation; either
  8.  * version 2 of the License, or (at your option) any later version.
  9.  *
  10.  * This library is distributed in the hope that it will be useful,
  11.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  12.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  13.  * See the GNU Library General Public License for more details.
  14.  *
  15.  * You should have received a copy of the GNU Library General Public
  16.  * License along with this library; if not, write to the Free
  17.  * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  18.  *
  19.  * This file is version 0.9.13 of 17-July-95
  20.  * Check for the latest version of this package via anonymous ftp at
  21.  *    roxi.rz.fht-mannheim.de:/pub/languages/forth/pfe-VERSION.tar.gz
  22.  * or    sunsite.unc.edu:/pub/languages/forth/pfe-VERSION.tar.gz
  23.  * or    ftp.cygnus.com:/pub/forth/pfe-VERSION.tar.gz
  24.  *
  25.  * Please direct any comments via internet to
  26.  *    duz@roxi.rz.fht-mannheim.de.
  27.  * Thank You.
  28.  */
  29. /*
  30.  * forth-83.c ---     Compatiblity with the FORTH-83 standard.
  31.  *
  32.  * All FORTH-83-Standard words are included here that are not in the
  33.  * dpANS already.
  34.  * Though most of the "uncontrolled reference words" are omitted.
  35.  *
  36.  * (duz 08Aug93)
  37.  */
  38.  
  39. #include "forth.h"
  40. #include "support.h"
  41. #include "compiler.h"
  42.  
  43. #include <stdlib.h>
  44. #include <errno.h>
  45. #include <string.h>
  46.  
  47. #include "missing.h"
  48.  
  49. /************************************************************************/
  50. /* required word set                                                    */
  51. /************************************************************************/
  52.  
  53. Code (two_plus)            /* 2+ */
  54. {
  55.   *sp += 2;
  56. }
  57.  
  58. Code (two_minus)        /* 2- */
  59. {
  60.   *sp -= 2;
  61. }
  62.  
  63. Code (compile)            /* COMPILE */
  64. {
  65.   compile1 ();
  66.   bracket_compile_ ();
  67. }
  68. code (postpone_execution);
  69. COMPILES (compile, postpone_execution,
  70.       SKIPS_CELL, DEFAULT_STYLE);
  71.  
  72. void
  73. vocabulary_runtime (void)
  74. {
  75.   CONTEXT[0] = (Wordl *) PFA;
  76. }
  77.  
  78. Code (vocabulary)        /* VOCABULARY */
  79. {
  80.   header (vocabulary_runtime, 0);
  81.   word_list ();
  82. }
  83.  
  84. /************************************************************************/
  85. /* system extension word set                                            */
  86. /************************************************************************/
  87.  
  88. code (if_execution);        /* ?BRANCH */
  89. code (else_execution);        /* BRANCH */
  90.  
  91. code (backward_mark)        /* <MARK */
  92. {
  93.   question_comp_ ();
  94.   *--sp = (Cell) DP;
  95. }
  96.  
  97. code (backward_resolve)        /* <RESOLVE */
  98. {
  99.   question_comp_ ();
  100. #if 0
  101.   COMMA ((char *) *sp++ - (char *) DP);
  102. #else
  103.   COMMA (*sp++);
  104. #endif
  105. }
  106.  
  107. code (forward_mark)        /* MARK> */
  108. {
  109.   backward_mark_ ();
  110.   INC (DP, Cell);
  111. }
  112.  
  113. code (forward_resolve)        /* RESOLVE> */
  114. {
  115.   question_comp_ ();
  116. #if 0
  117.   *(Cell *) *sp = (char *) DP - (char *) *sp;
  118.   sp++;
  119. #else
  120.   *(Byte **) *sp++ = DP;
  121. #endif
  122. }
  123.  
  124. /************************************************************************/
  125. /* Controlled reference words                                           */
  126. /************************************************************************/
  127.  
  128. Code (next_block)        /* --> */
  129. {
  130.   question_loading_ ();
  131.   refill ();
  132. }
  133.  
  134. Code (k)            /* K (3rd loop index) */
  135. {
  136.   *--sp = RP[6] + RP[7];
  137. }
  138.  
  139. Code (octal)            /* OCTAL */
  140. {
  141.   BASE = 8;
  142. }
  143.  
  144. Code (s_p_fetch)        /* SP@ */
  145. {
  146.   void *p = sp;
  147.  
  148.   *--sp = (Cell) p;
  149. }
  150.  
  151. /************************************************************************/
  152. /* Some uncontrolled reference words                                    */
  153. /************************************************************************/
  154.  
  155. Code (store_bits)        /* !BITS */
  156. {
  157.   uCell mask = sp[0];
  158.   uCell *ptr = (uCell *) sp[1];
  159.   uCell bits = sp[2];
  160.  
  161.   sp += 3;
  162.   *ptr = (*ptr & ~mask) | (bits & mask);
  163. }
  164.  
  165. Code (power)            /* ** (raise second to top power) */
  166. {
  167.   Cell i = *sp++;
  168.   Cell n = *sp, m;
  169.  
  170.   for (m = 1; --i >= 0; m *= n);
  171.   *sp = m;
  172. }
  173.  
  174. Code (byte_swap)        /* >< */
  175. {
  176.   Byte *p = (Byte *) sp
  177. #if HIGHBYTE_FIRST
  178.   + (sizeof (Cell) - 2)
  179. #endif
  180.   , h;
  181.  
  182.   h = p[1];
  183.   p[1] = p[0];
  184.   p[0] = h;
  185. }
  186.  
  187. Code (byte_swap_move)        /* >MOVE< */
  188. {
  189.   Byte *p = (Byte *) sp[2];
  190.   Byte *q = (Byte *) sp[1];
  191.   Cell n = sp[0];
  192.  
  193.   sp += 3;
  194.   for (; n > 0; n -= 2)
  195.     {
  196.       q[1] = p[0];
  197.       q[0] = p[1];
  198.       p += 2;
  199.       q += 2;
  200.     }
  201. }
  202.  
  203. Code (fetch_bits)        /* @BITS */
  204. {
  205.   sp[1] = *(Cell *) sp[1] & sp[0];
  206.   sp++;
  207. }
  208.  
  209. /************************************************************************/
  210. /* Search order specification and control                               */
  211. /************************************************************************/
  212.  
  213. Code (seal)            /* SEAL */
  214. {
  215.   Wordl **w;
  216.  
  217.   for (w = CONTEXT; w <= &ONLY; w++)
  218.     if (*w == ONLY)
  219.       w = NULL;
  220. }
  221.  
  222. /************************************************************************/
  223. /* Definition field address conversion operators                        */
  224. /************************************************************************/
  225.  
  226. Code (to_name)            /* >NAME */
  227. {
  228.   *sp = (Cell) to_name ((Xt) *sp);
  229. }
  230.  
  231. Code (to_link)            /* >LINK */
  232. {
  233.   *sp = (Cell) to_link ((Xt) *sp);
  234. }
  235.  
  236. Code (body_from)        /* BODY> */
  237. {
  238.   *sp = (Cell) BODY_FROM (*sp);
  239. }
  240.  
  241. Code (name_from)        /* NAME> */
  242. {
  243.   *sp = (Cell) name_from ((char *) *sp);
  244. }
  245.  
  246. Code (link_from)        /* LINK> */
  247. {
  248.   *sp = (Cell) link_from ((char **) *sp);
  249. }
  250.  
  251. Code (l_to_name)        /* L>NAME */
  252. {
  253.   *sp = (Cell) link_to_name ((char **) *sp);
  254. }
  255.  
  256. Code (n_to_link)        /* N>LINK */
  257. {
  258.   *sp = (Cell) name_to_link ((char *) *sp);
  259. }
  260. /* *INDENT-OFF* */
  261. LISTWORDS (forth_83) =
  262. {
  263.   /* FORTH-83 required word set */
  264.   CO ("2+",        two_plus),
  265.   CO ("2-",        two_minus),
  266.   CO ("?TERMINAL",    key_question),
  267.   CS ("COMPILE",    compile),
  268.   CO ("NOT",        invert),
  269.   CO ("VOCABULARY",    vocabulary),
  270.   /* FORTH-83 system extension word set */
  271.   CO ("<MARK",        backward_mark),
  272.   CO ("<RESOLVE",    backward_resolve),
  273.   CO ("MARK>",        forward_mark),
  274.   CO ("RESOLVE>",    forward_resolve),
  275.   CO ("BRANCH",        else_execution),
  276.   CO ("?BRANCH",    if_execution),
  277.   DV ("CONTEXT",    context),
  278.   DV ("CURRENT",    current),
  279.   /* FORTH-83 controlled reference words */
  280.   CI ("-->",        next_block),
  281.   CO ("INTERPRET",    interpret),
  282.   CO ("K",        k),
  283.   CO ("OCTAL",        octal),
  284.   CO ("SP@",        s_p_fetch),
  285.   /* FORTH-83 uncontrolled reference words */
  286.   CO ("!BITS",        store_bits),
  287.   CO ("@BITS",        fetch_bits),
  288.   CO ("><",        byte_swap),
  289.   CO (">MOVE<",        byte_swap_move),
  290.   CO ("**",        power),
  291.   DV ("DPL",        dpl),
  292.   /* FORTH-83 Search order specification and control */
  293.   CO ("SEAL",        seal),
  294.   /* FORTH-83 definition field address conversion operators */
  295.   CO ("BODY>",        body_from),
  296.   CO (">LINK",        to_link),
  297.   CO ("LINK>",        link_from),
  298.   CO (">NAME",        to_name),
  299.   CO ("NAME>",        name_from),
  300.   CO ("L>NAME",        l_to_name),
  301.   CO ("N>LINK",        n_to_link)
  302. };
  303. COUNTWORDS (forth_83, "FORTH-83 compatibility");
  304.